home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / dosstuff < prev    next >
Text File  |  1992-04-25  |  27KB  |  1,202 lines
  1. /* dosstuff.c - MS/DOS 16 bit compiler specific sources */
  2. /* Handles Microsoft C (v4.0 or later), Turbo/Borland C (any version),
  3.    TopSpeed C (any version), and Zortech C (version 2 or later) in large
  4.    memory model. In addition handles Turbo/Borland C and TopSpeed C in
  5.    medium memory model, and the "x" (286 protected mode) model of Zortech C.*/
  6.  
  7. #include "xlisp.h"
  8. #include "osdefs.h"
  9.  
  10. #include <dos.h>
  11. #include <process.h>
  12. #include <math.h>
  13. #include <io.h>
  14. #include <float.h>
  15. #ifdef TIMES
  16. #include <time.h>
  17. #endif
  18.  
  19. #define LBSIZE 200
  20.  
  21. #ifdef __ZTC__
  22. #ifdef DOS16RM
  23. extern void * _cdecl D16SegAbsolute(long);  /* undocumented, but necessary, function*/
  24.  
  25. unsigned _cdecl _stack = 48000;     /* bigger stack in this case */
  26. #else
  27. unsigned _cdecl _stack = 16384;     /* set up reasonable stack */
  28. #endif
  29. #endif
  30. #ifdef __TURBOC__
  31. unsigned _Cdecl _stklen = 16384;        /* set up reasonable stack */
  32. #ifdef MEDMEM
  33. unsigned _Cdecl _heaplen = 4096;    /* compress the near heap */
  34. #endif
  35. #endif
  36.  
  37. #ifdef MSC
  38. /* MSC Doesn't define these */
  39. #define MK_FP(seg,ofs) (((unsigned long)(seg)<<16) | (unsigned)(ofs))
  40. #endif
  41.  
  42. /* external variables */
  43. extern LVAL s_unbound,s_dosinput,true;
  44. extern FILEP tfp;
  45.  
  46. /* exported variables */
  47. int lposition;
  48.  
  49.  
  50. /* local variables */
  51. static char lbuf[LBSIZE];
  52. static int lpos[LBSIZE];
  53. static int lindex;
  54. static int lcount;
  55.  
  56. /* forward declarations */
  57. void NEAR xinfo(void);
  58. void NEAR xflush(void);
  59. int  NEAR xgetc(void);
  60. void NEAR xputc(int ch);
  61. void NEAR setraw(void);
  62. void NEAR unsetraw(void);
  63.  
  64. /* math error handler */
  65.  
  66. #ifdef __TSC__          /* Top Speed wants matherr to be function pointer! */
  67. int newmatherr(struct exception *er)
  68. #else
  69. int CDECL matherr(struct exception *er)
  70. #endif
  71. {
  72.     char *emsg;
  73.  
  74.     switch (er->type) {
  75.         case DOMAIN: emsg="domain"; break;
  76.         case OVERFLOW: emsg="overflow"; break;
  77.         case PLOSS: case TLOSS: emsg="inaccurate"; break;
  78.         case UNDERFLOW: return 1;
  79.         default: emsg="????"; break;
  80.     }
  81.     xlerror(emsg,cvflonum(er->arg1));
  82.     return 0; /* never happens */
  83. }
  84.  
  85. /* osinit - initialize */
  86.  
  87. #ifdef MSC
  88. extern unsigned _amblksiz;
  89. #endif
  90.  
  91.  
  92. VOID osinit(banner)
  93.   char *banner;
  94. {
  95. #ifdef MSC
  96. /*  _amblksiz = 16; */
  97. #endif
  98. #ifdef __TSC__
  99.     matherr = newmatherr;
  100. #endif
  101.     setvbuf(stderr,NULL,_IOFBF,256);
  102.  
  103.     if (*(char FAR *)MK_FP(_psp,0x19) != *(char FAR *)MK_FP(_psp,0x1a))
  104.         redirectout = TRUE;
  105.     if (*(char FAR *)MK_FP(_psp,0x18) != *(char FAR *)MK_FP(_psp,0x1a))
  106.         redirectin = TRUE;
  107.  
  108.     fprintf(stderr,"%s\n",banner);
  109.     lposition = 0;
  110.     lindex = 0;
  111.     lcount = 0;
  112.     setraw();
  113.  
  114. #if defined( __TURBOC__) || defined(MSC) || defined(__TSC__)
  115.     /* let fp overflow pass and domain errors */
  116.     _control87(EM_OVERFLOW|EM_INVALID,EM_OVERFLOW|EM_INVALID);
  117. #endif
  118. #ifdef __TURBOC__
  119.     /* force raw mode for stderr */
  120.     stderr->flags |= _F_BIN;
  121. #endif
  122. }
  123.  
  124. /* osfinish - clean up before returning to the operating system */
  125. VOID osfinish()
  126. {
  127.         unsetraw();
  128. }
  129.  
  130. /* xoserror - print an error message */
  131. VOID xoserror(msg)
  132.   char *msg;
  133. {
  134.     fprintf(stderr,"error: %s\n",msg);
  135. }
  136.  
  137. /* osrand - return next random number in sequence */
  138. long osrand(rseed)
  139.   long rseed;
  140. {
  141.     long k1;
  142.  
  143.     /* make sure we don't get stuck at zero */
  144.     if (rseed == 0L) rseed = 1L;
  145.  
  146.     /* algorithm taken from Dr. Dobbs Journal, November 1985, page 91 */
  147.     k1 = rseed / 127773L;
  148.     if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
  149.         rseed += 2147483647L;
  150.  
  151.     /* return a random number between 0 and MAXFIX */
  152.     return rseed;
  153. }
  154.  
  155. #ifdef FILETABLE
  156.  
  157. int truename(char *name, char *rname)
  158. {
  159.     union REGS regs;
  160. #ifndef MEDMEM
  161.     struct SREGS sregs;
  162. #endif
  163.     int i;
  164.     char *cp;
  165.     int drive;          /* drive letter */
  166.     char pathbuf[FNAMEMAX+1];   /* copy of path part of name */
  167.     char curdir[FNAMEMAX+1];    /* current directory of drive */
  168.     char *fname;        /* pointer to file name part of name */
  169.     
  170.     /* use backslashes consistantly */
  171.     
  172.     for (cp = name; (cp = strchr(cp, '/')) != NULL; *cp = '\\') ;
  173.     
  174.     /* parse any drive specifier */
  175.  
  176.     if ((cp = strrchr(name, ':')) != NULL) {
  177.         if (cp != name+1 || !isalpha(*name)) return FALSE;
  178.         drive = toupper(*name);
  179.         name = cp+1;            /* name now excludes drivespec */
  180.     }
  181.     else {
  182.         regs.h.ah = 0x19;   /* get current disk */
  183.         intdos(®s, ®s);
  184.         drive = regs.h.al + 'A';
  185.     }
  186.     
  187.     /* check for absolute path (good news!) */
  188.     
  189.     if (*name == '\\') {
  190.         sprintf(rname,"%c:%s",drive,name);
  191.     }
  192.     else {
  193.         strcpy(pathbuf, name);
  194.         if ((cp = strrchr(pathbuf, '\\')) != NULL) {    /* path present */
  195.             cp[1] = 0;
  196.             fname = strrchr(name, '\\') + 1;
  197.         }
  198.         else {
  199.             pathbuf[0] = 0;
  200.             fname = name;
  201.         }
  202.  
  203.         /* get the current directory of the selected drive */
  204.         
  205.         regs.h.ah = 0x47;
  206.         regs.h.dl = drive + 1 - 'A';
  207. #ifdef MEDMEM
  208.         regs.x.si = (unsigned) curdir;
  209.         intdos(®s, ®s);
  210. #else
  211.         regs.x.si = (unsigned) FP_OFF(curdir);
  212.         sregs.ds = (unsigned) FP_SEG(curdir);
  213.         intdosx(®s, ®s, &sregs);
  214. #endif
  215.  
  216.         if (regs.x.cflag != 0) return FALSE;    /* invalid drive */
  217.     
  218.         /* peel off "..\"s */
  219.         while (strncmp(pathbuf, "..\\", 3) == 0) {
  220.             if (*curdir == 0) return FALSE;     /* already at root */
  221.             strcpy(pathbuf, pathbuf+3);
  222.             if ((cp=strrchr(curdir, '\\')) != NULL)
  223.                 *cp = 0;    /* peel one depth of directories */
  224.             else
  225.                 *curdir = 0;    /* peeled back to root */
  226.         }
  227.         
  228.         /* allow for a ".\" */
  229.         if (strncmp(pathbuf, ".\\", 2) == 0)
  230.             strcpy(pathbuf, pathbuf+2);
  231.         
  232.         /* final name is drive:\curdir\pathbuf\fname */
  233.  
  234.         if (strlen(pathbuf)+strlen(curdir)+strlen(fname)+4 > FNAMEMAX) 
  235.             return FALSE;
  236.         
  237.         if (*curdir)
  238.             sprintf(rname, "%c:\\%s\\%s%s", drive, curdir, pathbuf, fname);
  239.         else
  240.             sprintf(rname, "%c:\\%s%s", drive, pathbuf, fname);
  241.     }
  242.     
  243.     /* lowercase the whole string */
  244.  
  245.     for (cp = rname; (i = *cp) != 0; cp++) {
  246.         if (isupper(i)) *cp = tolower(i);
  247.     }
  248.     
  249.     return TRUE;
  250. }
  251.  
  252. extern void gc(void);
  253.  
  254. LOCAL int NEAR getslot(VOID)
  255. {
  256.     int i=0;
  257.  
  258.     for (; i < FTABSIZE; i++)   /* look for available slot */
  259.         if (filetab[i].fp == NULL) return i;
  260.  
  261.     gc();   /* is this safe??????? */
  262.  
  263.     for (i=0; i < FTABSIZE; i++) /* try again -- maybe one has been freed */
  264.         if (filetab[i].fp == NULL) return i;
  265.  
  266.     xlfail("too many open files");
  267.  
  268.     return 0;   /* never returns */
  269. }
  270.  
  271.  
  272. FILEP osaopen(const char *name, const char *mode)
  273. {
  274.     int i=getslot();
  275.     char namebuf[FNAMEMAX+1];
  276.     FILE *fp;
  277.  
  278.     if (!truename((char *)name, namebuf))
  279.         strcpy(namebuf, name);  /* should not happen */
  280.  
  281.     if ((filetab[i].tname = malloc(strlen(namebuf)+1)) == NULL) {
  282.         free(filetab[i].tname);
  283.         xlfail("insufficient memory");
  284.     }
  285.     
  286.     
  287.     if ((fp = fopen(name,mode)) == NULL) {
  288.         free(filetab[i].tname);
  289.         return CLOSED;
  290.     }
  291.  
  292.     filetab[i].fp = fp;
  293.  
  294.     strcpy(filetab[i].tname, namebuf);
  295.  
  296.     return i;
  297. }
  298.  
  299.  
  300. FILEP osbopen(const char *name, const char *mode)
  301. {
  302.     char bmode[10];
  303.  
  304.     strcpy(bmode,mode); strcat(bmode,"b");  
  305.  
  306.     return osaopen(name, bmode);
  307. }
  308.  
  309. VOID osclose(FILEP f)
  310. {
  311.     fclose(filetab[f].fp);
  312.     free(filetab[f].tname);
  313.     filetab[f].tname = NULL;
  314.     filetab[f].fp = NULL;
  315. }
  316.  
  317. #else
  318. /* osbopen - open a binary file */
  319. FILE * CDECL osbopen(const char *name, const char *mode)
  320. {
  321.     char bmode[10];
  322.     strcpy(bmode,mode); strcat(bmode,"b");
  323.     return (fopen(name,bmode));
  324. }
  325. #endif
  326.  
  327. #ifdef PATHNAMES
  328. /* ospopen - open for reading using a search path */
  329. FILEP ospopen(char *name, int ascii)
  330. {
  331.     FILEP fp;
  332.     char *path = getenv(PATHNAMES);
  333.     char *newnamep;
  334.     char ch;
  335.     char newname[256];
  336.  
  337.     /* don't do a thing if user specifies explicit path */
  338.     if (strchr(name,'/') != NULL && strchr(name, '\\') != NULL)
  339. #ifdef FILETABLE
  340.         return (ascii? osaopen: osbopen)(name,"r");
  341. #else
  342.         return fopen(name,(ascii? "r": "rb"));
  343. #endif
  344.  
  345.     do {
  346.         if (*path == '\0')  /* no more paths to check */
  347.             /* check current directory just in case */
  348. #ifdef FILETABLE
  349.             return (ascii? osaopen: osbopen)(name,"r");
  350. #else
  351.             return fopen(name,(ascii? "r": "rb"));
  352. #endif
  353.  
  354.         newnamep = newname;
  355.         while ((ch=*path++) != '\0' && ch != ';' && ch != ' ')
  356.             *newnamep++ = ch;
  357.  
  358.         if (ch == '\0') path--;
  359.  
  360.         if (newnamep != newname &&
  361.             *(newnamep-1) != '/' && *(newnamep-1) != '\\')
  362.             *newnamep++ = '/';  /* final path separator needed */
  363.         *newnamep = '\0';
  364.  
  365.         strcat(newname, name);
  366. #ifdef FILETABLE
  367.             fp = (ascii? osaopen: osbopen)(newname,"r");
  368. #else
  369.             fp = fopen(newname, ascii? "r": "rb");
  370. #endif
  371.     } while (fp == CLOSED); /* not yet found */
  372.  
  373.     return fp;
  374. }
  375. #endif
  376.  
  377. /* rename argument file as backup, return success name */
  378. /* For new systems -- if cannot do it, just return TRUE! */
  379.  
  380. int renamebackup(char *filename) {
  381.     char *bufp, ch=0;
  382.  
  383.     strcpy(buf, filename);  /* make copy with .bak extension */
  384.  
  385.     bufp = &buf[strlen(buf)];   /* point to terminator */
  386.     while (bufp > buf && (ch = *--bufp) != '.' && ch != '/' && ch != '\\') ;
  387.  
  388.  
  389.     if (ch == '.') strcpy(bufp, ".bak");
  390.     else strcat(buf, ".bak");
  391.  
  392.     remove(buf);
  393.  
  394.     return !rename(filename, buf);
  395. }
  396.  
  397. /* ostgetc - get a character from the terminal */
  398. int ostgetc()
  399. {
  400.     int ch;
  401.     union REGS regs;
  402.     struct SREGS segregs;
  403.  
  404.     /* check for a buffered character */
  405.     if (lcount-- > 0)
  406.         return (lbuf[lindex++]);
  407.  
  408.     /* get an input line */
  409.  
  410.     if (getvalue(s_dosinput) != NIL && !redirectin && !redirectout) {
  411.  
  412.         fflush(stderr);
  413.  
  414.         lindex = 2;
  415.         lbuf[0] = LBSIZE - 2;
  416.         regs.x.ax = 0x0A00;
  417.         regs.x.dx = FP_OFF(lbuf);
  418.         segregs.ds = FP_SEG(lbuf);
  419.         intdosx(®s,®s,&segregs);
  420.         putchar('\n');
  421.         lcount = lbuf[1];
  422.         lbuf[lcount+2] = '\n';
  423.         if (tfp!=CLOSED) OSWRITE(&lbuf[2],1,lcount+1,tfp);
  424.         lposition = 0;
  425.         return (lbuf[lindex++]);
  426.     }
  427.     else {
  428.  
  429.     for (lcount = 0; ; )
  430.         switch (ch = xgetc()) {
  431.         case '\r':
  432.         case '\n':
  433.                 lbuf[lcount++] = '\n';
  434.                 xputc('\r'); xputc('\n'); lposition = 0;
  435.                 if (tfp!=CLOSED) OSWRITE(lbuf,1,lcount,tfp);
  436.                 lindex = 0; lcount--;
  437.                 return (lbuf[lindex++]);
  438.         case '\010':
  439.         case '\177':
  440.                 if (lcount) {
  441.                     lcount--;
  442.                     while (lposition > lpos[lcount]) {
  443.                         xputc('\010'); xputc(' '); xputc('\010');
  444.                         lposition--;
  445.                     }
  446.                 }
  447.                 break;
  448.         case '\032':
  449.                 xflush();
  450.                 return (EOF);
  451.         default:
  452.                 if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
  453.                     lbuf[lcount] = ch;
  454.                     lpos[lcount] = lposition;
  455.                     if (ch == '\t')
  456.                         do {
  457.                             xputc(' ');
  458.                         } while (++lposition & 7);
  459.                     else {
  460.                         xputc(ch); lposition++;
  461.                     }
  462.                     lcount++;
  463.                 }
  464.                 else {
  465.                     xflush();
  466.                     switch (ch) {
  467.                     case '\003':    xltoplevel();   /* control-c */
  468.                     case '\007':    xlcleanup();    /* control-g */
  469.                     case '\020':    xlcontinue();   /* control-p */
  470.                     case '\032':    return (EOF);   /* control-z */
  471.                     case '\024':    xinfo();        /* control-t */
  472.                                     return ostgetc();
  473.                     default:        return (ch);
  474.                     }
  475.                 }
  476.         }}
  477. }
  478.  
  479. /* ostputc - put a character to the terminal */
  480. VOID ostputc(ch)
  481.   int ch;
  482. {
  483.     /* check for control characters */
  484.  
  485.     oscheck();
  486.  
  487.     /* output the character */
  488.     if (ch == '\n') {
  489.         xputc('\r'); xputc('\n');
  490.         lposition = 0;
  491.     }
  492.     else if (ch == '\t')
  493.         do { xputc(' '); } while (++lposition & 7);
  494.     else {
  495.         xputc(ch);
  496.         lposition++;
  497.    }
  498.  
  499.    /* output the character to the transcript file */
  500.    if (tfp!=CLOSED)
  501.         OSPUTC(ch,tfp);
  502. }
  503.  
  504. /* osflush - flush the terminal input buffer */
  505. VOID osflush()
  506. {
  507.     lindex = lcount = lposition = 0;
  508. }
  509.  
  510. /* oscheck - check for control characters during execution */
  511. VOID oscheck()
  512. {
  513.     int ch;
  514.  
  515.     if (!redirectin && (ch = (bdos(6,0xFF,0) & 0xff)) != 0)
  516.         switch (ch) {
  517.         case '\002':    /* control-b */
  518.             xflush();
  519.             xlbreak("BREAK",s_unbound);
  520.             break;
  521.         case '\003':    /* control-c */
  522.             xflush();
  523.             xltoplevel();
  524.             break;
  525.         case '\023':    /* control-s */
  526.             xgetc();    /* paused -- get character and toss */
  527.             break;
  528.         case '\024':    /* control-t */
  529.             xinfo();
  530.             break;
  531.         }
  532. }
  533.  
  534. /* xinfo - show information on control-t */
  535. static VOID NEAR xinfo()
  536. {
  537.     extern long nfree;
  538.     extern int gccalls;
  539.     extern long total;
  540.  
  541.     sprintf(buf,"\n[ Free: %ld, GC calls: %d, Total: %ld ]",
  542.             nfree,gccalls,total);
  543.     errputstr(buf);
  544.  
  545.     fflush(stderr);
  546. }
  547.  
  548. /* xflush - flush the input line buffer and start a new line */
  549. static VOID NEAR xflush()
  550. {
  551.     osflush();
  552.     ostputc('\n');
  553. }
  554.  
  555. /* xgetc - get a character from the terminal without echo */
  556. static int NEAR xgetc()
  557. {
  558.     fflush(stderr);
  559.  
  560.     if (!redirectin)
  561.         return (bdos(7,0,0) & 0xFF);
  562.     else {
  563. #ifdef __TURBOC__
  564.         char temp[1];
  565.         _read(2, temp, 1);
  566. #else
  567. #if defined(MSC) || defined(__TSC__)
  568.         char temp[1];
  569.         int dummy;
  570.         _dos_read(2, temp, 1, &dummy);
  571. #else
  572.         char temp[1];
  573.         read(2, temp, 1);
  574. #endif
  575. #endif
  576.         return temp[0];
  577.     }
  578. }
  579.  
  580. /* xputc - put a character to the terminal */
  581. static void NEAR xputc(ch)
  582.   int ch;
  583. {
  584.     fputc(ch,stderr);
  585.     if (ch == '\n') fflush(stderr);
  586. }
  587.  
  588. #ifdef OVERLAY
  589. /* Ralf Brown's SPAWNO package */
  590. #ifdef __TSC__
  591. int cdecl spawnvo(const char *overlay_path, const char *name, va_list args) ;
  592. #else
  593. #include "spawno.h"
  594. #endif
  595. #endif
  596.  
  597. /* xsystem - execute a system command */
  598. LVAL xsystem()
  599. {
  600.     char *cmd[4];
  601.     int ok;
  602.  
  603.     cmd[0] = getenv("COMSPEC");
  604.     if (moreargs()) {
  605.         cmd[1] = "/c";
  606. #ifdef MEDMEM
  607.         MEMCPY(buf, getstring(xlgastring()), STRMAX);
  608.         cmd[2] = buf;
  609. #else
  610.         cmd[2] = getstring(xlgastring());
  611. #endif
  612.         cmd[3] = NULL;
  613.         xllastarg();
  614.     }
  615.     else {
  616.         cmd[1] = NULL;
  617.     }
  618.     unsetraw();
  619.  
  620. #ifdef OVERLAY
  621.     ok = spawnvo("/",cmd[0], cmd);
  622. #else
  623.     ok = spawnv(P_WAIT,cmd[0], cmd);
  624. #endif
  625.  
  626.     setraw();
  627.     return (ok == 0 ? true : cvfixnum((FIXTYPE)errno));
  628. }
  629.  
  630. /* xgetkey - get a key from the keyboard */
  631. LVAL xgetkey()
  632. {
  633.     xllastarg();
  634.     return (cvfixnum((FIXTYPE)xgetc()));
  635. }
  636.  
  637. static unsigned savestate;
  638. static unsigned char savebrk;
  639.  
  640. #ifdef GRAPHICS
  641. static unsigned char origmode;
  642. static unsigned ourmode1=0, ourmode2=0;
  643.  
  644. static VOID NEAR setgmode(int ax, int bx)
  645. {
  646.     union REGS regs;
  647.     regs.x.ax = ax;
  648.     regs.x.bx = bx;
  649.     int86(0x10, ®s, ®s);
  650. }
  651.  
  652. #endif
  653.  
  654. /* setraw -- set raw mode */
  655. static VOID NEAR setraw(void)
  656. {
  657.     union REGS regs;
  658.  
  659.     regs.x.ax = 0x4400; /* get device status */
  660.     regs.x.bx = 2;
  661.     intdos(®s,®s);
  662.     regs.h.dh = 0;
  663.     savestate = regs.x.dx;
  664.     regs.x.ax = 0x4401;
  665.     regs.h.dl |= 0x20;
  666.     intdos(®s,®s);
  667.  
  668.     regs.x.ax = 0x3300; /* get ctrl-break status */
  669.     intdos(®s,®s);
  670.     savebrk = regs.h.dl;
  671.     regs.x.ax = 0x3301;
  672.     regs.h.dl = 0;
  673.     intdos(®s,®s);
  674.  
  675. #ifdef GRAPHICS
  676.     regs.x.ax = 0x0f00; /* get mode */
  677.     int86(0x10, ®s, ®s);
  678.     origmode = regs.h.al;
  679.     if (ourmode1 != 0)  /* mode was changed -- use it */
  680.         setgmode(ourmode1,ourmode2);
  681. #endif
  682. }
  683.  
  684. /* unsetraw -- restore original mode */
  685. static VOID NEAR unsetraw(void)
  686. {
  687.     union REGS regs;
  688.  
  689.     regs.x.ax = 0x4401;
  690.     regs.x.bx = 2;
  691.     regs.x.dx = savestate;
  692.     intdos(®s,®s);
  693.     regs.x.ax = 0x3301;
  694.     regs.h.dl = savebrk;
  695.     intdos(®s,®s);
  696.  
  697. #ifdef GRAPHICS
  698.     if ((ourmode1 !=0) && (ourmode2 != origmode))
  699.         setgmode(origmode,0);
  700. #endif
  701. }
  702.  
  703.  
  704. /* ossymbols - enter os specific symbols */
  705. VOID ossymbols()
  706. {
  707. }
  708.  
  709. #ifdef GRAPHICS
  710.  
  711. static union REGS regin, regout;
  712. static int xpos=0, ypos=0;
  713. static int Xmax=-1, Ymax=-1;
  714. static unsigned char drawvalue=15;
  715.  
  716. /* function goto-xy which set/obtains cursor position */
  717. LVAL xgotoxy()
  718. {
  719.     union REGS regs;
  720.     FIXTYPE x, y;
  721.     LVAL oldpos;
  722. #ifdef DOS16RM  /* kludge for 80286 protected mode */
  723.     unsigned char *basemem = D16SegAbsolute(0L);
  724. #endif
  725.  
  726.     fflush(stderr);
  727.  
  728.     regs.h.ah = 0x3;    /* get old position */
  729.     regs.h.bh = 0;
  730.     int86(0x10, ®s, ®s);
  731.     oldpos = cons(cvfixnum((FIXTYPE)regs.h.dl),
  732.                   cons(cvfixnum((FIXTYPE)regs.h.dh),NIL));
  733.  
  734.     if (moreargs()) {
  735.         x = getfixnum(xlgafixnum());
  736.         y = getfixnum(xlgafixnum());
  737.         xllastarg();
  738.         if (x < 0) x = 0;   /* check for in bounds */
  739. #ifdef DOS16RM
  740.         else if (x >= *(unsigned int FAR *)(basemem+0x44a))
  741.             x = *(unsigned int FAR *)(basemem+0x44a) - 1;
  742. #else
  743.         else if (x >= *(unsigned int FAR *) 0x44aL)
  744.             x = *(unsigned int FAR *) 0x44aL - 1;
  745. #endif
  746.         if (y < 0) y = 0;
  747. #ifdef DOS16RM
  748.         else if (*(basemem+0x484) != 0) {
  749.             if (y > *(basemem+0x484))
  750.                 y = *(basemem+0x484);
  751.         }
  752. #else
  753.         else if (*(unsigned char FAR *) 0x484L != 0) {
  754.             if (y > *(unsigned char FAR *) 0x484L)
  755.                 y = *(unsigned char FAR *) 0x484L;
  756.         }
  757. #endif
  758.         else if (y > 24) y = 24;
  759.  
  760.         regs.h.ah = 0x2;    /* set new position */
  761.         regs.h.dl = x;
  762.         regs.h.dh = y;
  763.         regs.h.bh = 0;
  764.  
  765.         int86(0x10, ®s, ®s);
  766.         lposition = (int)x;
  767.     }
  768.  
  769.     return oldpos;
  770. }
  771.  
  772. LVAL xcls() /* clear the screen */
  773. {
  774.     union REGS regs;
  775.     int xsize, ysize, attrib;
  776. #ifdef DOS16RM  /* kludge for 80286 protected mode */
  777.     unsigned char *basemem = D16SegAbsolute(0L);
  778. #endif
  779.  
  780.     fflush(stderr);
  781.     lposition = 0;
  782.  
  783. #ifdef DOS16RM
  784.     xsize = *(unsigned int FAR *)(basemem+0x44a);
  785.     ysize = (*(basemem+0x484) != 0 ? *(basemem+0x484) : 24);
  786.     attrib = (ourmode1 > 3 ? 0 : 
  787.         *(unsigned char FAR *)D16SegAbsolute(0xb8001L));
  788. #else
  789.     xsize = *(unsigned int FAR *) 0x44aL;
  790.     ysize = (*(unsigned char FAR *) 0x484L != 0 ?
  791.         *(unsigned char FAR *)0x484L : 24);
  792.     attrib = (ourmode1 > 3 ? 0 : *(unsigned char FAR *)0xb8000001L);
  793. #endif
  794.  
  795.     regs.x.ax = 0x0600;
  796.     regs.h.bh = attrib;
  797.     regs.x.cx = 0;
  798.     regs.h.dh = ysize;
  799.     regs.h.dl = xsize;
  800.     int86(0x10, ®s, ®s);
  801.     regs.h.ah =0x2;             /* home cursor */
  802.     regs.x.dx = 0;
  803.     regs.h.bh = 0;
  804.     int86(0x10, ®s, ®s);
  805.     return NIL;
  806. }
  807.  
  808. LVAL xcleol()   /* clear to end of line */
  809. {
  810.     union REGS regs;
  811.     fflush(stderr);
  812.  
  813.     regs.h.ah = 0x3;    /* get old position */
  814.     regs.h.bh = 0;
  815.     int86(0x10, ®s, ®s);  /* x position in regs.h.dl, y in regs.h.dh */
  816.     lposition = regs.h.dl;      /* just to be sure */
  817.     regs.x.cx = regs.x.dx;
  818. #ifdef DOS16RM
  819.     regs.h.dl = (*(unsigned int FAR *)D16SegAbsolute(0x44aL)) -1;/* x size */
  820.     regs.h.bh = (ourmode1 > 3 ? 0 : 
  821.         *(unsigned char FAR *)D16SegAbsolute(0xb8001L)); /* atrrib*/
  822. #else
  823.     regs.h.dl = *(unsigned int FAR *) 0x44aL -1;    /* x size */
  824.     regs.h.bh = (ourmode1 > 3 ? 0 : *(unsigned char FAR *)0xb8000001L); /* atrrib*/
  825. #endif
  826.     regs.x.ax = 0x0600;         /* scroll region */
  827.     int86(0x10, ®s, ®s);
  828.     return NIL;
  829. }
  830.  
  831.  
  832.  
  833. static LVAL NEAR draw(int x, int y, int x2, int y2)
  834.  
  835. {
  836.     int xStep,yStep,xDist,yDist;
  837.     int i, t8, t9, t10;
  838.  
  839.     fflush(stderr);
  840.  
  841.     if ((x < 0) | (x > Xmax) | (y < 0) | (y > Ymax) |
  842.         (x2 < 0)| (x2 > Xmax)  | (y2 < 0) | (y2 > Ymax))
  843.             return (NIL);
  844.  
  845.     x -= x2;     /* cvt to distance and screen coordiate (right hand) */
  846.     y2 = Ymax - y2;
  847.     y = (Ymax - y) - y2;
  848.  
  849.     if (x < 0) {    /* calculate motion */
  850.         xStep = -1;
  851.         xDist = -x;
  852.     }
  853.     else {
  854.         xStep = 1;
  855.         xDist = x;
  856.     }
  857.     if (y < 0) {
  858.         yStep = -1;
  859.         yDist = -y;
  860.     }
  861.     else {
  862.         yStep = 1;
  863.         yDist = y;
  864.     }
  865.  
  866.     regin.x.ax = drawvalue + 0x0c00;    /* write graphic pixel command */
  867.  
  868.     regin.x.cx = x2;        /* initial coordinates */
  869.     regin.x.dx = y2;
  870.  
  871.     int86(0x10,®in,®out); /* initial draw */
  872.  
  873.  
  874.     if (yDist == 0) {
  875.         i = xDist;
  876.         while (i--) {
  877.             regin.x.cx += xStep;
  878.             int86(0x10,®in,®out);
  879.         }
  880.     }
  881.     else if (xDist == yDist) {
  882.         i = xDist;
  883.         while (i--) {
  884.             regin.x.cx += xStep;
  885.             regin.x.dx += yStep;
  886.             int86(0x10,®in,®out);
  887.         }
  888.     }
  889.     else if (xDist == 0) {
  890.         i = yDist;
  891.         while (i--) {
  892.             regin.x.dx += yStep;
  893.             int86(0x10,®in,®out);
  894.         }
  895.     }
  896.     else if (xDist > yDist) {
  897.         t8 = 2*yDist;
  898.         t10 = 2*yDist - xDist;
  899.         t9 = 2*(yDist - xDist);
  900.         i = xDist;
  901.         while (i--) {
  902.             regin.x.cx += xStep;
  903.             if (t10 < 0) {
  904.                 t10 += t8;
  905.             }
  906.             else {
  907.                 regin.x.dx += yStep;
  908.                 t10 += t9;
  909.             }
  910.             int86(0x10,®in,®out);
  911.         }
  912.     }
  913.     else {
  914.         t8 = 2*xDist;
  915.         t10 = 2*xDist - yDist;
  916.         t9 = 2*(xDist - yDist);
  917.         i = yDist;
  918.         while (i--) {
  919.             regin.x.dx += yStep;
  920.             if (t10 < 0) {
  921.                 t10 += t8;
  922.             }
  923.             else {
  924.                 regin.x.cx += xStep;
  925.                 t10 += t9;
  926.             }
  927.             int86(0x10,®in,®out);
  928.         }
  929.     }
  930.     return (true);
  931. }
  932.  
  933.  
  934. /* xmode -- set display mode */
  935. /* called with either ax contents, or ax,bx,xsize,ysize */
  936. LVAL xmode()
  937. {
  938.     int nmode1, nmode2;
  939.     LVAL arg;
  940.  
  941.     arg = xlgafixnum();
  942.     nmode1 = (int) getfixnum(arg);
  943.  
  944.     if (moreargs()) {
  945.         arg = xlgafixnum();
  946.         nmode2 = (int) getfixnum(arg);
  947.         arg = xlgafixnum();
  948.         Xmax = (int) getfixnum(arg) - 1;    /* max x coordinate */
  949.         arg = xlgafixnum();
  950.         Ymax = (int) getfixnum(arg) - 1;    /* max y coordinate */
  951.         xllastarg();
  952.     }
  953.     else {
  954.         nmode2 = 0;
  955.         switch (nmode1) {
  956.         case 0: case 1: case 2: case 3:
  957.             Xmax = Ymax = -1; /* not a graphic mode */
  958.                  break;
  959.         case 4:
  960.         case 5:
  961.         case 13:
  962.         case 19: Xmax = 319;
  963.                  Ymax = 199;
  964.                  break;
  965.         case 6:
  966.         case 14: Xmax = 639;
  967.                  Ymax = 199;
  968.                  break;
  969.         case 16: Xmax = 639;
  970.                  Ymax = 349;
  971.                  break;
  972.         case 17:
  973.         case 18: Xmax = 639;    /* added VGA mode */
  974.                  Ymax = 479;
  975.                  break;
  976.         default:    return NIL; /* failed */
  977.         }
  978.     }
  979.  
  980.     ourmode1 = nmode1;
  981.     ourmode2 = nmode2;
  982.     setgmode(ourmode1,ourmode2); /* set mode */
  983.     return (true);
  984. }
  985.  
  986. /* xcolor -- set color */
  987.  
  988. LVAL xcolor()
  989. {
  990.     LVAL arg;
  991.  
  992.     arg = xlgafixnum();
  993.     xllastarg();
  994.  
  995.     drawvalue = (char) getfixnum(arg);
  996.  
  997.     return (arg);
  998. }
  999.  
  1000. /* xdraw -- absolute draw */
  1001.  
  1002. LVAL xdraw()
  1003. {
  1004.     LVAL arg = true;
  1005.     int newx, newy;
  1006.  
  1007.     while (moreargs()) {
  1008.         arg = xlgafixnum();
  1009.         newx = (int) getfixnum(arg);
  1010.  
  1011.         arg = xlgafixnum();
  1012.         newy = (int) getfixnum(arg);
  1013.  
  1014.         arg = draw(xpos,ypos,newx,newy);
  1015.  
  1016.         xpos = newx;
  1017.         ypos = newy;
  1018.     }
  1019.     return (arg);
  1020. }
  1021.  
  1022. /* xdrawrel -- absolute draw */
  1023.  
  1024. LVAL xdrawrel()
  1025. {
  1026.     LVAL arg = true;
  1027.     int newx, newy;
  1028.  
  1029.     while (moreargs()) {
  1030.         arg = xlgafixnum();
  1031.         newx = xpos + (int) getfixnum(arg);
  1032.  
  1033.         arg = xlgafixnum();
  1034.         newy = ypos + (int) getfixnum(arg);
  1035.  
  1036.         arg = draw(xpos,ypos,newx,newy);
  1037.  
  1038.         xpos = newx;
  1039.         ypos = newy;
  1040.     }
  1041.     return (arg);
  1042. }
  1043.  
  1044. /* xmove -- absolute move, then draw */
  1045.  
  1046. LVAL xmove()
  1047. {
  1048.     LVAL arg;
  1049.  
  1050.     arg = xlgafixnum();
  1051.     xpos = (int) getfixnum(arg);
  1052.  
  1053.     arg = xlgafixnum();
  1054.     ypos = (int) getfixnum(arg);
  1055.  
  1056.     return (xdraw());
  1057. }
  1058.  
  1059. /* xmoverel -- relative move */
  1060.  
  1061. LVAL xmoverel()
  1062. {
  1063.     LVAL arg;
  1064.  
  1065.     arg = xlgafixnum();
  1066.     xpos += (int) getfixnum(arg);
  1067.  
  1068.     arg = xlgafixnum();
  1069.     ypos += (int) getfixnum(arg);
  1070.  
  1071.     return (xdrawrel());
  1072. }
  1073.  
  1074. #endif
  1075. #ifdef TIMES
  1076. /* For some reason, every compiler is different ... */
  1077. #if defined(MSC) || defined(__TSC__)
  1078. unsigned long ticks_per_second() { return((unsigned long) CLK_TCK); }
  1079.  
  1080. unsigned long run_tick_count()
  1081. {
  1082.   return((unsigned long) clock()); /* Real time in MSDOS */
  1083. }
  1084.  
  1085. unsigned long real_tick_count()
  1086. {                                  /* Real time */
  1087.   return((unsigned long) clock());
  1088. }
  1089.  
  1090.  
  1091. LVAL xtime()
  1092. {
  1093.     LVAL expr,result;
  1094.     unsigned long tm;
  1095.  
  1096.     /* get the expression to evaluate */
  1097.     expr = xlgetarg();
  1098.     xllastarg();
  1099.  
  1100.     tm = run_tick_count();
  1101.     result = xleval(expr);
  1102.     tm = run_tick_count() - tm;
  1103.     sprintf(buf, "The evaluation took %.2f seconds.\n",
  1104.             ((double)tm) / ticks_per_second());
  1105.     trcputstr(buf);
  1106.  
  1107.     fflush(stderr);
  1108.  
  1109.     return(result);
  1110. }
  1111. #endif
  1112.  
  1113. #ifdef __ZTC__
  1114. unsigned long ticks_per_second() { return((unsigned long) CLK_TCK); }
  1115.  
  1116. unsigned long run_tick_count()
  1117. {
  1118.   return((unsigned long) clock()); /* Real time in MSDOS */
  1119. }
  1120.  
  1121. unsigned long real_tick_count()
  1122. {                                  /* Real time */
  1123.   return((unsigned long) clock());
  1124. }
  1125.  
  1126.  
  1127. LVAL xtime()
  1128. {
  1129.     LVAL expr,result;
  1130.     double tm;
  1131.  
  1132.     /* get the expression to evaluate */
  1133.     expr = xlgetarg();
  1134.     xllastarg();
  1135.  
  1136.     tm = run_tick_count();
  1137.     result = xleval(expr);
  1138.     tm = (run_tick_count() - tm) / CLK_TCK ;
  1139.     sprintf(buf, "The evaluation took %.2f seconds.\n", tm);
  1140.     trcputstr(buf);
  1141.  
  1142.     fflush(stderr);
  1143.     return(result);
  1144. }
  1145.  
  1146. #endif
  1147.  
  1148. #ifdef __TURBOC__
  1149. /* We want to cheat here because ticks_per_second would have to be rounded */
  1150.  
  1151. #define OURTICKS 1000
  1152.  
  1153. unsigned long ticks_per_second() {
  1154.     return((unsigned long) OURTICKS);
  1155. }
  1156.  
  1157. unsigned long run_tick_count()
  1158. {                               /*Real time in MSDOS*/
  1159.   return((unsigned long) ((OURTICKS/CLK_TCK)*clock()));
  1160. }
  1161.  
  1162. unsigned long real_tick_count()
  1163. {                               /* Real time */
  1164.   return((unsigned long) ((OURTICKS/CLK_TCK)*clock()));
  1165. }
  1166.  
  1167.  
  1168. LVAL xtime()
  1169. {
  1170.     LVAL expr,result;
  1171.     unsigned long tm;
  1172.  
  1173.     /* get the expression to evaluate */
  1174.     expr = xlgetarg();
  1175.     xllastarg();
  1176.  
  1177.     tm = run_tick_count();
  1178.     result = xleval(expr);
  1179.     tm = run_tick_count() - tm;
  1180.     sprintf(buf, "The evaluation took %.2f seconds.\n",
  1181.             ((double)tm) / ticks_per_second());
  1182.     trcputstr(buf);
  1183.  
  1184.     fflush(stderr);
  1185.  
  1186.     return(result);
  1187. }
  1188. #endif
  1189.  
  1190. LVAL xruntime() {
  1191.     xllastarg();
  1192.     return(cvfixnum((FIXTYPE) run_tick_count()));
  1193. }
  1194.  
  1195. LVAL xrealtime() {
  1196.     xllastarg();
  1197.     return(cvfixnum((FIXTYPE) real_tick_count()));
  1198. }
  1199.  
  1200.  
  1201. #endif
  1202.